home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 7.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  37KB  |  1,159 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "hdr.h"
  10. #include "libhdr.h"
  11. #include "vars.h"
  12. #include "setp.h"
  13. #include "errmsgp.h"
  14. #include "dclmapp.h"
  15. #include "libp.h"
  16. #include "miscp.h"
  17. #include "unitsp.h"
  18. #include "nodesp.h"
  19. #include "smiscp.h"
  20. #include "chapp.h"
  21. /* TBSL: check that check_priv_decl always called with first
  22.     argument (kind) as integer, corresponding to MISC_TYPE_ATTRIBUTE...
  23.  */
  24.  
  25. static int in_relevant_scopes(int);
  26. static Symbol trace_ancestor(Symbol, Tuple);
  27. static void private_part(Node);
  28.  
  29. void package_specification(Node node)    /*; package specification */
  30. {
  31.     Node    id_node, decl_node, priv_node;
  32.  
  33.     id_node   = N_AST1(node);
  34.     decl_node = N_AST2(node);
  35.     priv_node = N_AST3(node);
  36.     new_package(id_node, na_package_spec);
  37.     package_declarations(decl_node, priv_node);
  38.     end_specs(N_UNQ(id_node));
  39. }
  40.  
  41. void new_package(Node id_node, int nat)    /*;new_package*/
  42. {
  43.     /* Process a  package specification: install scope, initialize  mappings. */
  44.  
  45.     char    *id;
  46.     Symbol    ud;
  47.     int        body_number;
  48.  
  49.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_package");
  50.  
  51.     id = N_VAL(id_node);
  52.     new_compunit("sp", id_node);
  53.     if (nat==na_generic_part && IS_COMP_UNIT) {
  54.             /* allocate unit number for body, and mark it obsolete */
  55.             body_number = unit_number(strjoin("bo", id));
  56.             pUnits[body_number]->libInfo.obsolete = string_ds; /*"$D$"*/
  57.     }
  58.     newmod(id);
  59.  
  60.     N_UNQ(id_node) = scope_name;
  61.     NATURE(scope_name)  = nat;
  62.     TYPE_OF(scope_name) = symbol_none;
  63.     /* Create dummy entry to hold use clauses, which are declarative items.*/
  64.     find_new("$used");
  65.     /* use_declarations in SETL is signature(declared(scope_name), '$used') */
  66.     ud = dcl_get(DECLARED(scope_name), "$used");
  67.     SIGNATURE(ud) = tup_new(0);
  68.     private_decls(scope_name) = (Set) private_decls_new(0);
  69. }
  70.  
  71. void package_declarations(Node decl_node, Node priv_node)
  72.                                                     /*;package_declarations */
  73. {
  74.     char    *str;
  75.     Symbol    s1, u_name;
  76.     Fordeclared dcliv;
  77.  
  78.     adasem(decl_node);
  79.     /* The declarations so far constitute the visible part of the package*/
  80.     /* save current declarations */
  81.     /*    visible(scope_name) = declared(scope_name); */
  82.     FORDECLARED(str, s1, DECLARED(scope_name), dcliv);
  83.         IS_VISIBLE(dcliv) = TRUE;
  84.     ENDFORDECLARED(dcliv);
  85.  
  86.     FORDECLARED(str, u_name, DECLARED(scope_name), dcliv)
  87.         if (TYPE_OF(u_name) == symbol_incomplete) {
  88.         errmsg_id("missing full declaration for %", u_name, "3.8.1", decl_node);
  89.         }
  90.     ENDFORDECLARED(dcliv);
  91.     /* Now process private part of package.*/
  92.     private_part(priv_node);
  93. }
  94.  
  95. void module_body_id(int mod_nature, Node name_node)  /*;module_body_id*/
  96. {
  97.     /* This procedure is invoked when the name of a module body has been
  98.      * seen. It opens the new scope, and if necessary retrieves from the
  99.      * library the specifications for the module.
  100.      */
  101.  
  102.     Symbol    mod_name, c, real_t;
  103.     char    *spec_name;
  104.     int    nat, mattr, mark;
  105.     char    *id;
  106.     Symbol    s1, s2, t;
  107.     Fordeclared    fd1;
  108.     Forprivate_decls    fp1;
  109.     Private_declarations    pd;
  110.     Tuple    ud;
  111.     Symbol    uds; /* check tupe of this    ds 4 aug */
  112.     Fortup    ft1;
  113.  
  114.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  module_body_id");
  115.  
  116.     new_compunit("bo", name_node);
  117.  
  118.     find_old(name_node);
  119.     mod_name = N_UNQ(name_node);
  120.     if (!IS_COMP_UNIT && SCOPE_OF(mod_name) != scope_name) {
  121.         errmsg("Specification and body are in different scopes" , "7.1, 9.1",
  122.           name_node);
  123.     }
  124.  
  125.     /* Nature of specification must match that of current body*/
  126.  
  127.     /*
  128.      * const specs_of = { 
  129.      *     [na_package, {na_package_spec, na_generic_package_spec}],
  130.      *     [na_task_type, {na_task_type_spec, na_task_obj_spec}] };
  131.      * if (NATURE(mod_name) in specs_of(mod_nature) ) {
  132.      *     rmatch(nature(mod_name), '_spec');        $ not a spec any longer 
  133.      * }
  134.      */
  135.     nat = NATURE(mod_name);
  136.     if (mod_nature == na_package
  137.       && (nat == na_package_spec || nat == na_generic_package_spec)
  138.       || (mod_nature == na_task_type && (nat == na_task_type_spec
  139.       || nat == na_task_obj_spec 
  140.       || (nat == na_obj && NATURE(TYPE_OF(mod_name)) == na_task_type_spec)))) {
  141.         /* if the task appeared in a previously (separately) compiled unit,
  142.           * the expander has already changed its nature to na_obj
  143.           */
  144.         if (nat == na_package_spec) nat = na_package;
  145.         else if (nat == na_generic_package_spec)
  146.             nat = na_generic_package;
  147.         else if (nat == na_task_type_spec)
  148.             nat = na_task_type;
  149.         else if (nat == na_task_obj_spec)
  150.             nat = na_task_obj;
  151.         else if (nat == na_obj)
  152.             NATURE(TYPE_OF(mod_name)) = na_task_type;
  153.  
  154.         NATURE(mod_name) = nat;
  155.     }
  156.     else {
  157.         errmsg_nval("Matching specification not found for body %", name_node,
  158.           "7.1, 9.1", name_node);
  159.     }
  160.  
  161.     /* if module is a generic package body and the current unit is a package
  162.      * body, verify that the generic spec appeared in the same file.
  163.      */
  164.     if (NATURE(mod_name) == na_generic_package 
  165.       && streq(unit_name_type(unit_name), "bo")) {
  166.         if (is_subunit(unit_name))
  167.             spec_name = pUnits[stub_parent_get(unit_name)]->name;
  168.         else
  169.             spec_name = strjoin("sp", unit_name_name(unit_name));
  170.         if (!streq(lib_unit_get(spec_name), AISFILENAME))
  171.             errmsg("Separately compiled generics not supported", "none",
  172.               name_node);
  173.     }
  174.  
  175.     newscope (mod_name);    /* added to match SETL    gcs 23 jan */
  176.     if (private_decls(mod_name) == (Set)0)
  177.         private_decls(mod_name) = (Set) private_decls_new(0);
  178.     /* For safe processing of body.*/
  179.     if (DECLARED(mod_name) == (Declaredmap)0)
  180.         DECLARED(mod_name) = dcl_new(0);
  181.  
  182.     if (NATURE(mod_name) == na_task_type ) {
  183.         /* Within the body of a task type, the name of the task can be used 
  184.          * to designate the task currently executing the body. We create an 
  185.          * alias to be elaborated at run-time, under the name 'current_task'.
  186.          */
  187.         c = find_new(strjoin("", "current_task"));
  188.         TYPE_OF(c) = mod_name;
  189.         NATURE(c) = na_obj;
  190.     }
  191.     else if (NATURE(mod_name) == na_task_obj ) {
  192.         /* remove -spec marker from its anonymous task type as well.*/
  193.         NATURE(TYPE_OF(mod_name)) = na_task_type;
  194.     }
  195.     else if (mod_nature == na_package ) {
  196.         /* Within a package body, declarations from the private part of the
  197.          * specification are     visible. Swap    visible and  private versions.
  198.          */
  199.         pd = (Private_declarations) private_decls(mod_name);
  200.         FORPRIVATE_DECLS(s1, s2, pd, fp1);
  201.             private_decls_swap(s1, s2);
  202.         ENDFORPRIVATE_DECLS(fp1);
  203.         /* (forall [item, pdecl] in private_decls(mod_name))
  204.          * [SYMBTABF(item), private_decls(mod_name)(item)] :=
  205.          * [pdecl, SYMBTABF(item)];    
  206.          * end forall;
  207.          */
  208.         /* Furthermore, composite types that depend on (outer) private types
  209.          * may now be fully useable if the latter received full declarations,
  210.          * (as long as they do not depend in external private types...)
  211.          */
  212.         FORDECLARED(id, t, DECLARED(mod_name), fd1);
  213.             if (NATURE(t) == na_package_spec && !tup_mem((char *) t, vis_mods) )
  214.                 vis_mods = tup_with(vis_mods, (char *) t);
  215.             else if (! is_type(t)) continue;
  216.             mattr = (int) misc_type_attributes(t);
  217.             mark = 0;
  218.             if (mattr & TA_PRIVATE)
  219.                 mark = TA_PRIVATE;
  220.             else if (mattr & TA_LIMITED_PRIVATE)
  221.                 mark = TA_LIMITED_PRIVATE;
  222.             /* exclude the mark 'limited' from this test (gs apr 1 85) */
  223.             /* else if (mattr & TA_LIMITED)
  224.              * mark = TA_LIMITED;
  225.              */
  226.             else if (mattr & TA_INCOMPLETE)
  227.                 mark = TA_INCOMPLETE;
  228.             if (mark == 0) continue;
  229.             if (is_access(t)) real_t = (Symbol) designated_type(t);
  230.             else real_t = t;
  231.  
  232.             if (!is_private(real_t) ) {
  233.                 /* full declaration  of private ancestor(s) has been seen.
  234.                  * save visible declaration before updating.
  235.                  */
  236.                 private_decls_put((Private_declarations)
  237.                   private_decls(mod_name), t);
  238.                 misc_type_attributes(t) = (misc_type_attributes(t) & ~mark );
  239.             }
  240.         ENDFORDECLARED(fd1);
  241.         /* and install the use clauses that were encountered in the
  242.          * specification.
  243.          */
  244.         uds = dcl_get(DECLARED(mod_name), "$used");
  245.         if ( uds != (Symbol)0 ) {
  246.             ud = SIGNATURE(uds);
  247.             FORTUP(uds=(Symbol), ud, ft1);
  248.                 used_mods = tup_with(used_mods, (char *) uds);
  249.             ENDFORTUP(ft1);
  250.         }
  251.         /* Else the body was not found. Error was emitted already.*/
  252.     }
  253.  
  254.     /* Initialize the stacks used for label processing.*/
  255.     lab_init();
  256. }
  257.  
  258. void module_body(int nat, Node block_node)    /*;module_body*/
  259. {
  260.  
  261.     Symbol    mod_name, scope;
  262.     char    *spec_name;
  263.     Tuple        specs, nodes, context;
  264.     Node    decls, stats, except, id_node;
  265.     Symbol    u_name;
  266.     Tuple    tup;
  267.     int    i;
  268.     Symbol    s1, s2;
  269.     Forprivate_decls    fp1;
  270.     Private_declarations    pd;
  271.     Fordeclared        fd1;
  272.     Fortup            ft1;
  273.     Tuple        scopes, must_constrain;
  274.     Unitdecl    ud;
  275.     char    *utnam;
  276.     char    *did;
  277.     Symbol    t_name, unit_unam;
  278.     Tuple    old_vis;
  279.     int    scopei;
  280.     Tuple    decmaps, decscopes, gen_list;
  281.  
  282.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  module_body");
  283.  
  284.     mod_name = scope_name;
  285.     decls = N_AST2(block_node);
  286.     stats = N_AST3(block_node);
  287.     except = N_AST4(block_node);
  288.     /* Each task type can refer to an instance of itself; dynamically,
  289.      * such an instance is constructed under the name 'current_task'. We
  290.      * introduce a declaration for a dummy task object with taht name.
  291.      */
  292.     if (NATURE(mod_name) == na_task_type) {
  293.         id_node = node_new(as_simple_name);
  294.         N_VAL(id_node) = strjoin("", "current_task");
  295.         find_old(id_node);
  296.         N_KIND(id_node) = as_current_task;
  297.         copy_span(N_AST1(block_node), id_node);
  298. #ifdef TBSN
  299.         SPANS(id_node)    = [left_span(decls)];
  300. #endif
  301.         /*N_LIST(decls) := [id_node] + N_LIST(decls) */
  302.         tup = N_LIST(decls);
  303.         tup = tup_exp(tup, (unsigned) tup_size(tup)+1);
  304.         for (i=tup_size(tup);i>1;i--)
  305.             tup[i] = tup[i-1];
  306.         tup[1] = (char *) id_node;
  307.         N_LIST(decls) = tup;
  308.     }
  309.  
  310.     lab_end();
  311.     check_incomplete_decls(mod_name, block_node);
  312.     popscope()    ;
  313.     /* Having finished the module body, we now restore the visible
  314.      * declarations saved in module_body_id (If it is a package).
  315.      */
  316.     if (nat == na_package  || nat == na_generic_package) {
  317.         pd = (Private_declarations) private_decls(mod_name);
  318.         FORPRIVATE_DECLS(s1, s2, pd, fp1);
  319.             private_decls_swap(s1, s2);
  320.         ENDFORPRIVATE_DECLS(fp1);
  321.     }
  322.  
  323.     if (NATURE(mod_name) == na_generic_package) {
  324.         /* We must update the declarations for the current unit, to
  325.          * include  the generic body. This  can be  done  omly if the
  326.          * generic  specification appears in the current compilation,
  327.          * which is a restriction on the current  implementation that
  328.          * will be lifted some day.
  329.          * For purposes of generic instantiation, we must save not only
  330.          * the visible part of the package, but all declarations in the
  331.          * body as well, including declarations     for nested non-generic
  332.          * objects. This parallels what is done at the point of instan-
  333.          * tiation. 
  334.          *
  335.          * Replace the opt_node that marks the place of the body in the 
  336.          * generic spec, with the body node.
  337.          * Set fifth component of signature to tuple of generic private types
  338.          * that must be constrained upon instantiation.
  339.          */
  340.  
  341.         SIGNATURE(mod_name)[4] = (char *) block_node;
  342.         gen_list = (Tuple) SIGNATURE(mod_name)[1];
  343.         must_constrain = tup_new(0);
  344.         FORTUP(tup=(Tuple), gen_list, ft1)
  345.             t_name = (Symbol)tup[1];
  346.             if ((int)misc_type_attributes(t_name) & TA_CONSTRAIN)
  347.                 must_constrain=tup_with(must_constrain, (char *)t_name);
  348.         ENDFORTUP(ft1);
  349.         SIGNATURE(mod_name)[5] = (char *) must_constrain;
  350.  
  351.         utnam = unit_name_type(unit_name);
  352.         if (IS_COMP_UNIT) {
  353.             pUnits[unit_number(unit_name)]->libInfo.obsolete = string_ok;
  354. #ifdef IBM_PC
  355.             pUnits[unit_number(unit_name)]->libInfo.obsolete = strjoin("ok", "");
  356. #endif
  357.         }
  358.         if (streq(utnam, "bo") || streq(utnam, "su")
  359.           && streq(unit_name_name(unit_name), unit_name_names(unit_name)) ){
  360.             spec_name = strjoin("sp", unit_name_name (unit_name));
  361.             if (lib_unit_get(spec_name) != (char *)0
  362.               && streq(lib_unit_get(spec_name) , AISFILENAME)
  363.               && unit_decl_get(spec_name)!=(Unitdecl)0 ) {
  364.                 /* Unpack unit specification.*/
  365.                 ud = unit_decl_get(spec_name);
  366.                 unit_unam = ud->ud_unam;
  367.                 /*specs = utup[5];*/
  368.                 specs = ud->ud_symbols;
  369.                 decscopes = ud->ud_decscopes;
  370.                 old_vis = ud->ud_oldvis;
  371.                 decmaps = ud->ud_decmaps;
  372.                 scopes = tup_new1((char *) mod_name);
  373.                 nodes = ud->ud_nodes;
  374.                 context =ud->ud_context;
  375.  
  376.                 /*  Update the specs of generic types, that may carry the
  377.                  * marker "$constrain', because of usage in body.
  378.                  */
  379.                 FORDECLARED(did, t_name, DECLARED(mod_name), fd1);
  380.                     if( is_generic_type(t_name))
  381.                         /*specs(t_name) := SYMBTABF(t_name);*/
  382.                         specs = sym_save(specs, t_name, 'u');
  383.                 ENDFORDECLARED(fd1);
  384.                 while (tup_size(scopes) >0) {
  385.                     scope =(Symbol) tup_frome(scopes);
  386.  
  387.                     /*specs(scope)  = SYMBTABF(scope);*/
  388.                     specs = sym_save(specs, scope, 'u');
  389.                     scopei = tup_memi((char *) scope, decscopes);
  390.                     if (scopei == 0) {
  391.                         decscopes = tup_exp(decscopes,
  392.                           (unsigned) tup_size(decscopes)+1);
  393.                         decmaps = tup_exp(decmaps,
  394.                           (unsigned) tup_size(decmaps)+1);
  395.                         scopei = tup_size(decscopes);
  396.                         decscopes[scopei] = (char *) scope;
  397.                     }
  398.                     decmaps[scopei] = (char *) dcl_copy(DECLARED(scope));
  399.                     /* body_decls      = declared(scope) -
  400.                      *   (visible(scope) ? {});
  401.                      * notvis(scope) = body_decls;
  402.                      */
  403.                     /* TBSL: Review following when do generics    ds 1 aug */
  404.                     /*(forall [-, u_name] in body_decls)*/
  405.                     FORDECLARED(did, u_name, DECLARED(scope), fd1);
  406.                         if (IS_VISIBLE(fd1)) continue;
  407.                         /*specs(u_name) := SYMBTABF(u_name);*/
  408.                         specs = sym_save(specs, u_name, 'u');
  409.  
  410.                         if (DECLARED(u_name) != (Declaredmap)0
  411.                           && ! can_overload(u_name)
  412.                           && NATURE(u_name) != na_generic_package)
  413.                             /* Contains further collectible decls.*/
  414.                             if (!tup_mem((char *) u_name, scopes))
  415.                                 scopes = tup_with(scopes, (char *) u_name);
  416.                     ENDFORDECLARED(fd1);
  417.                 }
  418.                 /*specs(mod_name) := SYMBTABF(mod_name);*/
  419.                 specs = sym_save(specs, mod_name, 'u');
  420.                 /* Repackage the unit's information.*/
  421.                 /* UNIT_DECL(spec_name) :=
  422.                  * [unit_unam, specs, decmap, old_vis, notvis, context,
  423.                  * nodes with block_node];
  424.                  */
  425.                 ud = unit_decl_get(spec_name);
  426.                 if (ud == (Unitdecl)0) ud = unit_decl_new();
  427.                 /* TBSL see if tup_copy's needed before saving tuples in utup */
  428.                 ud->ud_unam = unit_unam;
  429.                 ud->ud_useq = S_SEQ(unit_unam);
  430.                 ud->ud_unit = S_UNIT(unit_unam);
  431.                 ud->ud_symbols = specs;
  432.                 ud->ud_decscopes = decscopes;
  433.                 ud->ud_oldvis = old_vis;
  434.                 ud->ud_decmaps = decmaps;
  435.                 ud->ud_context = tup_copy(context);
  436.                 ud->ud_nodes = tup_with(nodes, (char *) block_node);
  437.                 unit_decl_put(spec_name, ud);
  438.             }
  439.             else if (IS_COMP_UNIT) {
  440.                 /* Repackage as a specification. */
  441.  
  442.                 newscope(mod_name);    /* For end_specs*/
  443.                 end_specs(mod_name);
  444.             }
  445.         }
  446.     } /* end if na_generic_package() */
  447.  
  448.     if (nat != na_task) save_body_info(mod_name);
  449. }
  450.  
  451. void private_decl(Node node)    /*;private_decl*/
  452. {
  453.     char    *id, *priv_kind_str;
  454.     Symbol    name, priv_kind;
  455.     Node    id_node, opt_discr, priv_kind_node;
  456.     int    nat;
  457.  
  458.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  private_decl");
  459.  
  460.     id_node = N_AST1(node);
  461.     opt_discr = N_AST2(node);
  462.     priv_kind_node = N_AST3(node);
  463.  
  464.     id = N_VAL(id_node);
  465.     sem_list(opt_discr);
  466.     priv_kind_str = N_VAL(priv_kind_node);
  467.     if (streq(priv_kind_str, "private"))
  468.         priv_kind = symbol_private;
  469.     else if (streq(priv_kind_str, "limited_private"))
  470.         priv_kind = symbol_limited_private;
  471.     else {
  472.         printf("private_decl: invalid priv_kind_str %s\n",
  473.             priv_kind_str);
  474.         chaos("bad priv_kind_str");
  475.     }
  476.  
  477.     if (dcl_get(DECLARED(scope_name), id) == (Symbol)0) {
  478.         name = find_new(id);
  479.         TYPE_OF(name) = priv_kind;
  480.         root_type(name) = name;
  481.         newscope(name);
  482.         process_discr(name, opt_discr);
  483.         NATURE(name) = na_type;
  484.         /*initialize_representation_info(name, TAG_RECORD);*/
  485.         /* This should be private_dependents (in SETL, it is the same as 
  486.          *   misc_type_attributes)
  487.          *   misc_type_attributes(name) = 0; 
  488.          */
  489.         private_dependents(name) = set_new(0);
  490.         popscope();
  491.  
  492.         nat = NATURE(scope_name);
  493.         if (nat!=na_package_spec && nat !=na_generic_package_spec
  494.           && nat!=na_generic_part) {
  495.             errmsg("Invalid context for private declaration", "7.4, 12.1.2",
  496.               node);
  497.         }
  498.     }
  499.     else{
  500.         errmsg("Invalid redeclaration ", "8.2", id_node);
  501.         name = symbol_any;
  502.     }
  503.  
  504.     N_UNQ(id_node) = name;
  505. }
  506.  
  507. void check_fully_declared(Symbol type_mark)            /*;check_fully_declared*/
  508. {
  509.     /* Called from object and constant declarations, to ensure that a
  510.      * private or incomplete type is not used in a declaration before its
  511.      * full declaration has been seen.
  512.      */
  513.  
  514.     Symbol    t;
  515.  
  516.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_fully_declared");
  517.  
  518.     t = base_type(type_mark);
  519.  
  520.     if (TYPE_OF(t) == symbol_incomplete || private_ancestor(t) != (Symbol)0) {
  521.         errmsg_id("invalid use of type % before its full declaration",
  522.           type_mark, "3.8.1, 7.4.1", current_node);
  523.     }
  524.     /* If the type is a generic private type, and is used as an unconstrained
  525.      * subtype indication, note that its instantiations will have to be
  526.      * with a constrained type.
  527.      */
  528.     check_generic_usage(type_mark);
  529. }
  530.  
  531. void check_fully_declared2(Symbol type_mark)        /*;check_fully_declared2*/
  532. {
  533.     /* Called from array element and component declarations, to ensure that
  534.      * an incomplete type is not used in a declaration before its
  535.      * full declaration has been seen.
  536.      */
  537.  
  538.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_fully_declared2");
  539.  
  540.     check_incomplete(type_mark);
  541.     check_generic_usage(type_mark);
  542. }
  543.  
  544. int is_private(Symbol type_mark)                            /*;is_private*/
  545. {
  546.     /* Determine whether a type has a private subcomponent. This differs
  547.      * from what is done in private_ancestor, where only incomplete priv.
  548.      * subcomponents are of interest.
  549.      */
  550.  
  551.     Fordeclared    fd1;
  552.     char        *id;
  553.     Symbol        comp;
  554.  
  555.     if (in_priv_types(TYPE_OF(base_type(type_mark))) ) return TRUE;
  556.     if (in_priv_types(TYPE_OF(root_type(type_mark))) ) return TRUE;
  557.     if (is_array(type_mark) && is_private(component_type(type_mark)))
  558.         return TRUE;
  559.  
  560.     if (is_record(type_mark)) {
  561.         FORDECLARED(id, comp ,
  562.           (Declaredmap) declared_components(base_type(type_mark)), fd1)
  563.             if (is_private(TYPE_OF(comp)) ) return TRUE;
  564.         ENDFORDECLARED(fd1);
  565.         return FALSE;
  566.     }
  567. }
  568.  
  569. int is_limited_type(Symbol type_mark)    /*;is_limited_type*/
  570. {
  571.     /* A type is limited if its root type is a limited private type or a task
  572.      * type, or if it is a composite type some of whose components are limit-
  573.      * ted. The attributes 'limited' and 'limited private' are attached to
  574.      * such composite types when they are created by a definition, derivation
  575.      * or subtype declaration.
  576.      */
  577.  
  578.     Fordeclared    fd1;
  579.     int    mt;
  580.     char    *id;
  581.     Symbol    comp;
  582.  
  583.     if (TYPE_OF(base_type(type_mark)) == symbol_limited_private) return TRUE;
  584.     if (TYPE_OF(root_type(type_mark)) == symbol_limited_private) return TRUE;
  585.     if (is_task_type(type_mark)) return TRUE;
  586.  
  587.     mt = (int) misc_type_attributes(type_mark);
  588.  
  589.     if ((mt & TA_LIMITED) && (! is_access(type_mark))) return TRUE;
  590.  
  591.     if ((mt & TA_LIMITED_PRIVATE) == 0)     return FALSE;
  592.     if (! in_open_scopes(SCOPE_OF(type_mark) ) && ! is_access(type_mark))
  593.         return TRUE;
  594.     if (is_array(type_mark) &&    is_limited_type(component_type(type_mark)))
  595.         return TRUE;
  596.     if (is_record(type_mark) == FALSE) return FALSE;
  597.     FORDECLARED(id, comp, 
  598.       (Declaredmap)declared_components(base_type(type_mark)), fd1)
  599.         if (is_limited_type(TYPE_OF(comp)) )  return TRUE;
  600.     ENDFORDECLARED(fd1)
  601.     return FALSE;
  602. }
  603.  
  604. void check_out_parameters(Tuple formals)             /*;check_out_parameters */
  605. {
  606.     /*  enforce restrictions on usage of out formal parameters given in
  607.      *  LRM 7.4.4
  608.      */
  609.  
  610.     Symbol type_mark, scope;
  611.     Fortup ft;
  612.     int  nat, mode;
  613.     Tuple tup;
  614.  
  615.     FORTUP(tup=(Tuple), formals, ft);
  616.         mode = (int)tup[2];
  617.         type_mark = (Symbol)tup[3];
  618.         scope = SCOPE_OF(type_mark);
  619.         nat = NATURE(scope);
  620.         if (mode != na_out || is_access(type_mark))
  621.             continue;
  622.         else if (TYPE_OF(type_mark) == symbol_limited_private
  623.           && (nat == na_package_spec || nat == na_generic_package_spec 
  624.           || nat == na_generic_part )
  625.           && !in_private_part(scope) && tup_mem((char *)scope, open_scopes) ) {
  626.             /* We    are in the visible  part of  the package that declares
  627.              * the type. Its  full  decl. will  have to be  given with an
  628.              * assignable type.
  629.              */
  630.             misc_type_attributes(type_mark) =  
  631.               (misc_type_attributes(type_mark)) | TA_OUT;
  632.         }
  633.         else if (is_limited_type(type_mark)) {
  634.             errmsg_id("Invalid use of limited type % for out parameter ",
  635.               type_mark, "7.4.4", current_node);
  636.         }
  637.     ENDFORTUP(ft);
  638. }
  639.  
  640. int in_private_part(Symbol scope)                    /*;in_private_part */
  641. {
  642.     Fortup ft;
  643.     Symbol sym;
  644.  
  645.     FORTUP(sym=(Symbol), open_scopes, ft);
  646.         if (NATURE(sym) == na_private_part 
  647.           && streq(ORIG_NAME(sym), ORIG_NAME(scope)))
  648.             return TRUE;
  649.     ENDFORTUP(ft);
  650.     return FALSE;
  651. }
  652.  
  653. int private_kind(Symbol type_mark)                        /*;private_kind*/
  654. {
  655.     /* We must distinguish between fully limited types, such as task types,
  656.      * and    limited private types, which  are not limited  in the  defining
  657.      * package body. Limited private types become limited when used outside
  658.      * of their scope  of definition, and so  do composite    types with such
  659.      * components, or derived  types of them. This procedure is used to set
  660.      * the corresponding attribute in a type definition.
  661.      *   Generic  limited types  and composites of them are always limited.
  662.      * These attribtues are also used to detect premature access to composite
  663.      * types that have incomplete subcomponents. If a subcomponent is a generic
  664.      * private type, there is no question of premature access (e.g. it is legal
  665.      * to have aggregates of this composite type).
  666.      */
  667.     /* This procedure is only used to return one of the attributes maintained
  668.      * is misc_type_attributes, and hence returns one of the values
  669.      * TA_...
  670.      */
  671.  
  672.     Symbol    r, t;
  673.     int    kind, tattr;
  674.  
  675.     r = root_type(type_mark);
  676.     kind=0;
  677.     do {
  678.         if (is_scalar_type(type_mark))  {
  679.             kind = 0;
  680.             break;
  681.         }
  682.  
  683.         t = TYPE_OF(r);
  684.         if (t == symbol_private) {
  685.             kind = TA_PRIVATE;
  686.             break;
  687.         }
  688.         if (t == symbol_limited_private) {
  689.             kind = TA_LIMITED_PRIVATE;
  690.             break;
  691.         }
  692.  
  693.         tattr = (int)misc_type_attributes(type_mark);
  694.         if (tattr &TA_PRIVATE) {
  695.             kind = TA_PRIVATE;
  696.             break;
  697.         }
  698.         if (tattr & TA_LIMITED_PRIVATE) {
  699.             kind = TA_LIMITED_PRIVATE;
  700.             break;
  701.         }
  702.         if (tattr & TA_LIMITED) {
  703.             kind = TA_LIMITED;
  704.             break;
  705.         }
  706.         if (tattr & TA_INCOMPLETE) {
  707.             kind = TA_INCOMPLETE;
  708.             break;
  709.         }
  710.         if (is_task_type(type_mark)) {
  711.             kind =    TA_LIMITED;
  712.             break;
  713.         }
  714.  
  715.         if (is_access(type_mark)) {
  716.             t = TYPE_OF((Symbol)base_type((Symbol) designated_type(type_mark)));
  717.             if (t == symbol_private)
  718.                 kind = TA_PRIVATE;
  719.             else if (t == symbol_limited_private)
  720.                 kind = TA_LIMITED_PRIVATE;
  721.             else if (t == symbol_limited)
  722.                 kind = TA_LIMITED;
  723.             else if (t == symbol_incomplete)
  724.                 kind = TA_INCOMPLETE;
  725.         }
  726.     } while (0);
  727.  
  728.     if (kind == TA_LIMITED_PRIVATE
  729.       && (is_generic_type(type_mark) || ! in_open_scopes(SCOPE_OF(r))))
  730.         kind = TA_LIMITED;
  731.     if (kind == TA_PRIVATE && is_generic_type(type_mark)) kind = 0;
  732.     return (kind);
  733. }
  734.  
  735. int is_fully_private(Symbol type_mark)        /*;is_fully_private*/
  736. {
  737.     /* Check whether a composite type has an 'incomplete' private component.*/
  738.  
  739.     int    a;
  740.  
  741. #ifdef TBSN
  742.     const f_types = ['private', 'limited_private', 'incomplete'];
  743.  
  744.     return    is_set (a :
  745.         = misc_type_attributes(type_mark))
  746.             and exists kind in f_types | kind in a;
  747. #endif
  748.     a = (int) misc_type_attributes(base_type(type_mark));
  749.     return a & (TA_PRIVATE | TA_LIMITED_PRIVATE | TA_INCOMPLETE);
  750. }
  751.  
  752. void check_priv_decl(int kind, Symbol type_name)    /*;check_priv_decl*/
  753. {
  754.     /* Verify that the full declaration of a private type satisfies the
  755.      * restrictions stated in 7.4.1., 7.4.4.
  756.      */
  757.  
  758.     Tuple    disc_list;
  759.     Symbol    package_name, ps, t;
  760.     Set    attributes;
  761.     int    typeattr;
  762.     Forset    fs1;
  763.  
  764.     package_name = SCOPE_OF(type_name);
  765.     if (kind == TA_PRIVATE && is_limited_type(TYPE_OF(type_name)) ) {
  766.         errmsg("Private type requires full declaration with non limited type",
  767.           "7.4.1", current_node);
  768.         return;
  769.     }
  770.     else if (NATURE(type_name) == na_array) {
  771.         errmsg_l("Private type cannot be fully declared as an unconstrained",
  772.           " array type", "7.4.1", current_node);
  773.         return;
  774.     }
  775.     else {
  776.         /* If the private type is not declared with discriminants, it cannot
  777.          * be instantiated with a type with discriminants. Retrieve the pri-
  778.          * vate declaration to find if discriminant list was present.
  779.          */
  780.         /* [-, -, [-, disc_list], attributes ] :=
  781.          *   private_decls(package_name)(type_name);
  782.          */
  783.         ps = private_decls_get(
  784.           (Private_declarations) private_decls(package_name), type_name);
  785.         disc_list = (Tuple) (SIGNATURE(ps))[3]; /*is 3rd comp. in C */
  786.         attributes = private_dependents(ps);
  787.         typeattr = misc_type_attributes(ps);
  788.  
  789.         if (can_constrain(type_name) && tup_size(disc_list) == 0) {
  790.             errmsg_l("Private type without discriminants cannot be given ",
  791.               "full declaration with discriminants", "7.4.1", current_node);
  792.             /* and viceversa.*/
  793.         }
  794.         else if (tup_size(disc_list) != 0 && NATURE(type_name) !=na_record ) {
  795.             /* TBSL - see why following line commented out    ds 2 aug */
  796.             /*|| !has_discriminants(type_name)*/
  797.                 errmsg_l("A private type with discriminants must be given ",
  798.                   "full declaration with a discriminated type", "7.4.1",
  799.                   current_node);
  800.             /*    else if ('out' in_attributes ? {} {*/
  801.         }
  802.         else if ( (typeattr & TA_OUT) && is_limited_type(type_name) ) {
  803.             errmsg_l("Use of type for an OUT parameter requires full ",
  804.               "declaration  with non limited type", "7.4.4", current_node);
  805.         }
  806.     }
  807.     /* Composite types defined in the package and which include a component
  808.      * whose type is type_name are now usable in full (if type_name itself is
  809.      * not limited). They  may be defined in the visible part of the package,
  810.      * or in the (current) private part.
  811.      * The private dependents are part of the attributes of the private type.
  812.      */
  813.     if (!is_limited_type(type_name)) {
  814.         if (attributes != (Set)0) {
  815.             FORSET(t=(Symbol), attributes, fs1);
  816.                 if (SCOPE_OF(t) == package_name || SCOPE_OF(t) == scope_name)  {
  817.                     /* Save visible definition before updating.*/
  818.                     private_decls_put((Private_declarations)
  819.                       private_decls(package_name), t);
  820.                     /* private_decls(package_name)(t) := SYMBTABF(t); */
  821.                     /*    set_less(misc_type_attributes(t) , kind);*/
  822.                     misc_type_attributes(t) =
  823.                       ((int)misc_type_attributes(t) & ~kind);
  824.                 }
  825.             ENDFORSET(fs1)
  826.         }
  827.     }
  828.     check_generic_usage(type_name);
  829. }
  830.  
  831. static int in_relevant_scopes(int n)                /*;in_relevant_scopes*/
  832. {
  833.     /* called from private_ancestor to test membership in 
  834.      * SETL constant tuple relevant_scopes
  835.      */
  836.  
  837.     return (n== na_package_spec || n == na_generic_package_spec
  838.       || n == na_private_part || n == na_generic_part);
  839. }
  840.  
  841. Symbol private_ancestor(Symbol type_name)    /*;private_ancestor*/
  842. {
  843.     /* A type name has  a private ancestor    if it  is a subtype of, or has a
  844.      * component which is a subtype of, a private type whose full definition
  845.      * has not been seen yet. If the private ancestor of  t is defined, then
  846.      * t cannot  appear in    a type derivation,  and its  elaboration must be
  847.      * performed after that of the ancestor.
  848.      */
  849.  
  850.     if (in_relevant_scopes(NATURE(scope_name))
  851.       || ((NATURE(scope_name) == na_record || NATURE(scope_name) == na_void)
  852.       && in_relevant_scopes(NATURE(SCOPE_OF(scope_name)))))
  853.         return trace_ancestor(type_name, tup_new(0));
  854.     else
  855.         return (Symbol)0;
  856. }
  857.  
  858. static Symbol trace_ancestor(Symbol type_name, Tuple seen_prev)
  859.                                                             /*;trace_ancestor*/
  860. {
  861.     Fordeclared    fd1;
  862.     char        *id;
  863.     Symbol        comp, pr;
  864.     int        nat;
  865.     Tuple        seen;
  866.  
  867. #ifdef TBSL
  868.     -- note that seen is declared as set in SETL 
  869. #endif
  870.     /* Insertion of type names to the tuple seen must remain local to current
  871.      * invocation of this recursive procedure and not affect the calling one.
  872.      * Thus, a local copy of the tuple is created upon each entry to this
  873.      * procedure.
  874.      * the parameter name seen has been changed to seen_prev.
  875.      */
  876.     seen = tup_copy(seen_prev);
  877.  
  878.     /* Recursive procedure to find the private components of a composite
  879.      * type. this procedure uses a collection variable in order to detect 
  880.      * (invalid) recursive type definitions of private types.
  881.       */
  882.     if (tup_mem((char *) type_name, seen)) {
  883.         errmsg_id("recursive definition of private type %", type_name,
  884.           "7.2", current_node);
  885.         return type_name;
  886.     }
  887.     else
  888.         seen = tup_with(seen, (char *) type_name);
  889.  
  890.     if (is_scalar_type(type_name)) return (Symbol)0;
  891.     else if (in_priv_types(TYPE_OF(type_name))
  892.       && in_open_scopes(SCOPE_OF(type_name))) {
  893.         if (!is_generic_type(type_name))
  894.             return type_name;
  895.         else           /* A generic type is never seen by the interpreter */
  896.             return (Symbol)0;
  897.     }
  898.     else {
  899.         nat = NATURE(type_name);
  900.         if (nat == na_subtype)
  901.             return trace_ancestor(base_type(type_name), seen);
  902.         else if (nat == na_array)
  903.             return trace_ancestor((Symbol) component_type(type_name), seen);
  904.         else if (nat == na_record) {
  905.             FORDECLARED(id, comp,
  906.                 (Declaredmap)declared_components(base_type(type_name)), fd1);
  907.                 /* anonymous subtypes are generated for subtype indications in
  908.                  * component declarations, and appear in the declared map of 
  909.                  * records, but need not be examined here. 
  910.                  */
  911.                 if (NATURE(comp) == na_subtype) continue;
  912.                 pr = trace_ancestor(TYPE_OF(comp), seen);
  913.                 if (pr!=(Symbol)0) return pr;
  914.             ENDFORDECLARED(fd1);
  915.         }
  916.         else if (nat == na_access)
  917.             /* Access types need not be deferred.*/
  918.             return (Symbol)0;
  919.     }
  920.     return (Symbol)0; /* If none of the above.*/
  921. }
  922.  
  923. static void private_part(Node priv_node)                    /*;private_part*/
  924. {
  925.     char *nam;
  926.     Symbol    u_name;
  927.     Fordeclared    fd1;
  928.     Private_declarations    pd;
  929.     Forprivate_decls    fp1;
  930.     Symbol    vis_decl;
  931.     int    nat;
  932.     Node    save_current_node;
  933.  
  934.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  private_part");
  935.  
  936.     nat = NATURE(scope_name);            /* save */
  937.     NATURE(scope_name) = na_private_part;
  938.     save_current_node = current_node;    /* will be changed by adasem */
  939.     adasem(priv_node);
  940.     force_all_types();
  941.     NATURE(scope_name) = nat;            /* restore */
  942.     current_node = (priv_node != OPT_NODE ? priv_node : save_current_node);
  943.     /* Check that private types and deferred constants received
  944.      * full declarations.
  945.      */
  946.  
  947.     FORDECLARED(nam, u_name, DECLARED(scope_name), fd1 );
  948.         if (IS_VISIBLE(fd1)) { 
  949.           if ((in_priv_types(TYPE_OF(u_name)) 
  950.                 && SCOPE_OF(u_name) == scope_name
  951.                   && !is_generic_type(u_name)) 
  952.             || (NATURE(u_name) == na_constant 
  953.                 && (Node)SIGNATURE(u_name) == OPT_NODE)) {
  954.             /* Private object did not get private description.*/
  955.                 errmsg_str("Missing full declaration in private part for %",
  956.                           nam, "7.4.1", current_node);
  957.            }
  958.         }
  959.     ENDFORDECLARED(fd1);
  960.     /* Now exchange contents of private_decls and symbol table. In this
  961.      * fashion the declarations that were visible in the private part of
  962.      * the package, and that will be visible in the package body, become
  963.      * inaccessible outside of the package specification.
  964.      */
  965.     pd = (Private_declarations) private_decls(scope_name);
  966.     FORPRIVATE_DECLS(u_name, vis_decl, pd, fp1);
  967.         private_decls_swap(u_name, vis_decl);
  968.     ENDFORPRIVATE_DECLS(fp1);
  969. }
  970.  
  971. void end_specs(Symbol nam)        /*;end_specs*/
  972. {
  973.     /* This procedure is invoked at the end of a module specification.
  974.      * If this spec. is a compilation unit, then we save in UNIT_DECL
  975.      * all the declarations processed for the module. These declarations
  976.      * are retrieved (by procedure get_specs) when the separate compilation
  977.      * facility is used.
  978.      * In the case of generic modules, we must we must save the
  979.      * specs of the generic object in its signature, to simplify its instan-
  980.      * tiation. In order to insure that a separately compiled generic object
  981.      * is properly saved, we make the object name accessible within its own
  982.      * scope. This insures that its symbol table entry is correctly saved.
  983.      */
  984.  
  985.     int    kind;
  986.     Tuple    old_vis, vis_units;
  987.     Fortup    ft1;
  988.     Symbol    v;
  989.     char    *v_spec_name;
  990.  
  991.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : end_specs(nam) ");
  992.  
  993.     kind = NATURE(nam);
  994.  
  995.     /* save visible mods for this scope.*/
  996.     old_vis = tup_new(0);
  997.     FORTUP(v=(Symbol), vis_mods, ft1);
  998.         if (v!=symbol_ascii)
  999.             old_vis = tup_with(old_vis, (char *) v);
  1000.         /*old_vis = [v in vis_mods | v /= 'ASCII'];*/
  1001.     ENDFORTUP(ft1);
  1002.  
  1003.     popscope();
  1004.  
  1005.     vis_units = tup_new(0);
  1006.     FORTUP(v=(Symbol), old_vis, ft1);
  1007.         v_spec_name = strjoin("sp", original_name(v));
  1008.         if (unitNumberFromName(v_spec_name))
  1009.             vis_units = tup_with(vis_units, original_name(v));
  1010.     ENDFORTUP(ft1);
  1011.  
  1012.     if (IS_COMP_UNIT)
  1013.         save_spec_info(nam, vis_units);
  1014.     else {
  1015.         /* If the module is a sub-unit, make sure that it is visible in
  1016.          * its enclosing scope (except if it is a generic package).
  1017.          */
  1018.         FORTUP(v=(Symbol), old_vis, ft1);
  1019.             if (! tup_mem((char *) v, vis_mods))
  1020.                 vis_mods = tup_with(vis_mods, (char *) v);
  1021.         ENDFORTUP(ft1);
  1022.         /*vis_mods +:= [v in old_vis | v notin vis_mods];*/
  1023.         if (kind != na_generic_package_spec)
  1024.             vis_mods =  tup_with(vis_mods, (char *) nam);
  1025.     }
  1026. }
  1027.  
  1028. void check_incomplete_decls(Symbol scope, Node msg_node)
  1029.                                                     /*;check_incomplete_decls*/
  1030. {
  1031.     /* At the end of a block, verify that entities that need a body received
  1032.      * one.
  1033.      */
  1034.  
  1035.     Fordeclared    fd1;
  1036.     Fortup    ft1;
  1037.     char    *id, *stub;
  1038.     Symbol    name;
  1039.     int    exists;
  1040.  
  1041.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : check_incomplete_decls");
  1042.  
  1043.     if (DECLARED(scope) != (Declaredmap)0) {
  1044.         FORDECLARED(id, name, DECLARED(scope), fd1);
  1045.                         /* Limit the check to only entities declared in this
  1046.                          * scope to avoid checking packages that are renamings
  1047.                          * of things in other scopes.
  1048.                          */
  1049.             if ((SCOPE_OF(name) == scope) &&
  1050.                             needs_body(name) && !is_anonymous_task(name)) {
  1051.                 exists = FALSE;
  1052.                 FORTUP(stub=(char *), lib_stub, ft1);
  1053.                     if (streq(unit_name_name(stub), original_name(name)))
  1054.                         exists = TRUE;
  1055.                 ENDFORTUP(ft1);
  1056.                 if (!exists)  {
  1057.                     errmsg_nat_id_str("Missing body for % %.%", name, scope,
  1058.                       id, "7.3", msg_node);
  1059.                     continue;
  1060.                 }
  1061.             }
  1062.             if (TYPE_OF(name) == symbol_incomplete) {
  1063.                 errmsg_str(
  1064.                   "Missing full type declaration for incomplete type %",
  1065.                   id, "3.8.1", msg_node);
  1066.             }
  1067.         ENDFORDECLARED(fd1);
  1068.     }
  1069. }
  1070.  
  1071. Symbol get_specs(char *name)        /*;get_specs*/
  1072. {
  1073.     /* Install the specification for a package. This is done in two cases :
  1074.      * a) When we process the WITH clause of a new compilation unit.
  1075.      * b) When we compile the body of a package. The corresponding
  1076.      * package specification must have been compiled already, an must be
  1077.      * available. 
  1078.      */
  1079.  
  1080.     char    *spec_name, *u;
  1081.     int    i, notin;
  1082.     Tuple    decscopes, decmaps, vis_units, specs;
  1083.     Symbol    v, sn;
  1084.     Fortup    ft1, ft2;
  1085.     Symbol    unit_unam, uname, maybe_decl;
  1086.     Unitdecl ud;
  1087.  
  1088.     if (cdebug2 > 3) {
  1089.         TO_ERRFILE("AT PROC :  get_specs");
  1090.         printf("get_specs for %s\n", name);
  1091.     }
  1092.  
  1093.     spec_name = strjoin("sp", name);
  1094.     if (!retrieve(spec_name)) {
  1095.         errmsg_str("Cannot find package specification for %", name, "10.1",
  1096.           current_node);
  1097.         return (Symbol)0;
  1098.     }
  1099.     /* Read in the unique names and the declared types of all visible
  1100.      * names in the module specification.
  1101.      */
  1102.     /*[unit_unam, specs, decmap, old_vis, notvis] := UNIT_DECL(spec_name);*/
  1103.     ud = unit_decl_get(spec_name);
  1104.     if (ud == (Unitdecl) 0) chaos("get_specs, unit_decl_get returned 0 - exit");
  1105.     unit_unam = ud->ud_unam;
  1106.     specs = ud->ud_symbols;
  1107.     decscopes = ud->ud_decscopes;
  1108.     vis_units = ud->ud_oldvis;
  1109.     decmaps = ud->ud_decmaps;
  1110.  
  1111.     /* SYMTAB restore */
  1112.     symtab_restore(specs);
  1113.  
  1114.     /* (for dec = decmap(sn))
  1115.      * declared(sn) := dec;
  1116.      * if notvis(sn) /= om then   $ only defined for non-generic packages.
  1117.      * visible(sn) :=    dec - notvis(sn);
  1118.      * end if;
  1119.      * end for;
  1120.      */
  1121.     FORTUPI(sn=(Symbol), decscopes, i, ft1);
  1122.         /* TBSL - see if need do dcl_copy when restore, as did copy when saved*/
  1123. #ifdef TBSL
  1124.     -- translate if notvis(sn)... test above to C    ds 2-jan-85 
  1125.         -- need loop over declared map to see if any entries not visible.
  1126. #endif
  1127.         if (decmaps[i]!=(char *)0)
  1128.             DECLARED(sn) = dcl_copy((Declaredmap) decmaps[i]);
  1129.     ENDFORTUP(ft1);
  1130.     /*
  1131.      * Predefined unit that are mentioned in a WITH clauses are not saved in
  1132.      * UNIT_LIB, for storage reasons. Their contents must be brought in ex-
  1133.      * plicitly, but their direct visibility must not be modified.
  1134.      */
  1135.     /* (for u in vis_units | u notin vis_mods) */
  1136.     FORTUP(u=(char *), vis_units, ft1);
  1137.         notin = TRUE;
  1138.         FORTUP(v=(Symbol), vis_mods, ft2);
  1139.             if (streq(u, original_name(v))) notin = FALSE;
  1140.         ENDFORTUP(ft2);
  1141.         if (notin) {
  1142.             maybe_decl = dcl_get(DECLARED(symbol_standard0), u);
  1143.             uname = get_specs(u);
  1144.             /*
  1145.              * dcl_put(DECLARED(symbol_standard0),u,maybe_decl);
  1146.              *   this line raises chaos for duplicate entry in dcl_put,
  1147.              *   so we explicitly undefine and then restore previous value
  1148.              */
  1149.             dcl_undef(DECLARED(symbol_standard0),u);
  1150.             if (maybe_decl !=(Symbol)0)
  1151.                 dcl_put(DECLARED(symbol_standard0),u,maybe_decl);
  1152.             vis_mods = tup_with(vis_mods, (char *)  uname);
  1153.         }
  1154.     ENDFORTUP(ft1);
  1155.     if (dcl_get(DECLARED(symbol_standard0), name) == (Symbol)0)
  1156.         dcl_put(DECLARED(symbol_standard0), name, unit_unam);
  1157.     return unit_unam;
  1158. }
  1159.